Shareware Grab Bag/Shareware Grab Bag.iso/090/utility.arc/UTILITY.INC

Text File | 1985-02-10 | 11.6 KB | 390 lines

{Utility.Inc}

{ This utility include file includes the utility files printed in PC TECH
  JOURNAL, Feb. 1985.  For a complete write up of this procedures, read the
  article that accompanied them. }

(*************************************************************************)

{ Turbo Pascal procedure to retrieve command line parameters }
{ Copyritght 1984 Michael A. Covengton }

Type Parmtype = string[127];

procedure getparm(Var s:parmtype);

  { Returns first available parameter from DOS command }
  { line and removes it so next parameter will be      }
  { returned on next call.  If no more parameters are  }
  { avaiable, returns a null string.                   }

var parms : parmtype absolute CSEG:$80;
begin
  s := '';
  { parms[1] exists enen when length is zero }
  while (Length(Parms) > 0) and (parms[1] = ' ') do
    delete(Parms,1,1);
  While (length(parms) > 0) and (parms[1] <> ' ') do
    begin
      s := s + parms[1]; delete(parms,1,1);
    End
end;

(*************************************************************************)

{ Turbo Pascal routines to read and set date and time }
{ copyright 1984 Michael A. Covington }

{ Each routine requires the following type definitions }
{ but does not require the other routines.             }

type datetimetype = string[8];
     regtype     = record
                     ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
                   end;

function date : datetimetype;
  { returns current date in form '08/31/84'.}
var reg     : regtype;
    y,m,d,w : datetimetype;
    i       : integer;
begin
  reg.ax := $2A00;
  intr($21,reg);
  str(reg.cx:4,y);
  delete(y,1,2);
  str(hi(reg.dx):2,m);
  str(lo(reg.dx):2,d);
  w := m +'/' + d + '/' + y;
  for i := 1 to length(w) do if w[i]=' ' then w[i] := '0';
  date := w;
end;

function time : datetimetype;
  { return current time in form '08:13:59'.}
var reg     : regtype;
    h,m,s,w : datetimetype;
    i       : integer;
begin
  reg.ax := $2C00;
  intr($21,reg);
  str(hi(reg.cx):2,h);
  str(lo(reg.cx):2,m);
  str(hi(reg.dx):2,s);
  w := h + ':' + m + ':' + s;
  for i := 1 to length(w) do if w[i] = ' ' then w[i] := '0';
  time := w;
end;

procedure setdate(x:datetimetype);
  { set date.  accepts string in fromat '08/31/84'.}
var reg            : regtype;
    rh,rl,c1,c2,c3 : integer;
begin
  reg.ax := $2B00;
  val(x[1]+x[2],rh,c1);     {month goes in DH}
  val(x[4]+x[5],rl,c2);     {day goes in DL  }
  reg.dx := rh * 256 + rl;
  val(x[7]+x[8],rl,c3);     {year goes ni CX }
  reg.cx := rl + 1900;
  if rl < 80 then reg.cx := reg.cx + 100;  {21st century}
  c1 := c1 + c2 + c3;       {return codes for val}
  if c1 = 0 then intr($21,reg);
  if c1+lo(reg.ax) <> 0 then
    begin
      writeln;
      writeln('Error -- invalid date, ''',x,'''');
      halt;
    end;
end;

procedure settime(x:datetimetype);
  { set time  accepts string in format '08:13:59'.}
var reg            : regtype;
    rh,rl,c1,c2,c3 : integer;
begin
  reg.ax := $2D00;
  val(x[1]+x[2],rh,c1);       {hours go in CH  }
  val(x[4]+x[5],rl,c2);       {minutes go in CL}
  reg.cx := rh * 256 + rl;
  val(x[7]+x[8],rh,c3);       {seconds go in DH}
  reg.dx := rh*256;
  c1 := c1 + c2 + c3;         {return codes for val}
  if c1 = 0 then intr($21,reg);
  if c1+lo(reg.ax) <> 0 then
    begin
      writeln;
      writeln('Error -- invalid time, ''',x,'''');
      halt;
    end;
end;

(*************************************************************************)

{ Turbo Pascal routines for tree-structured directories }
{ copyright 1984 Michael a. Covinton }

{ requires MS-DOs or PC-DOS 2.0 or higher, execpt as noted }

{ All the rouintes require these type defintions.          }
{ However, except as noted, they do not require each other.}

type pathtype  = string[63];
     drivetype = string[2];
{instead of the rtype in TECH JOURNAL the regtype defined earlier will be used}

procedure xxdiskerr(x:drivetype);
begin
  writeln('Error -- invalid disk drive, ''',x,'''');
  halt;
end;

procedure xxpatherr(x:pathtype);
begin
  writeln('Error -- invalid path, ''',x,'''');
  halt;
end;

function currentdrive : drivetype;
  { returns designator for current default drive, e.g., 'A:'.}
  { works under DOS version 1.}
var w   : drivetype;
    reg : regtype;   {note earlier change in rtype name}
begin
  reg.ax := $1900;
  intr($21,reg);
  w := 'A:';
  w[1] := chr(ord(w[1])+lo(reg.ax));
  currentdrive := w;
end;

procedure chdrive(x:drivetype);
  { chooses a new default drive.                          }
  { parameter can have the form 'A:', 'A', 'a:', or 'a'.  }
  { works under DOS version 1.  requires xxdiskerr, above }
var reg : regtype;  {note earlier change in rtype name}
begin
  reg.ax := $0E00;
  reg.dx := ord(upcase(x[1])) - ord('A');
  intr($21,reg);
  if (reg.dx < 0) or (lo(reg.ax) < lo(reg.dx)) then xxdiskerr(x);
end;

function diskspace(x:drivetype) : real;
  { returns number of bytes available on specified disk.  }
  { parameter as for chdrive.  requires xxdiskerr, above  }
var reg : regtype;  {note earlier change in rtype name}
begin
  reg.ax := $3600;
  reg.dx := 1 + ord(upcase(x[1])) - ord('A');
  intr($21,reg);
  if reg.ax = $FFFF then
    xxdiskerr(x)
  else
    diskspace := ( 256.0 * hi(reg.dx) + ln(reg.dx) ) * reg.ax * reg.cx;
end;

function currentdir(x:drivetype) : pathtype;
  { returns full path to active directory on specified drive. }
  { including backslash at beginning, not including drive     }
  { designator.  Parameter as for chdrive.                    }
  { requires xxdiskerr, above                                 }
var w   : pathtype;
    reg : regtype;    {note earlier change in rtype name}
    i   : integer;
begin
  { get current path }
  reg.ax := $4700;
  reg.dx := 1 + ord(upcase(x[1])) - ord('A');
  reg.ds := seg(w[1]);
  reg.si := ofs(w[1]);
  intr($21,reg);
  if (reg.flags and 1) > 0 then xxdiskerr(x);
  { turn it into a Turob string }
  I := 1;
  while w[i] <> chr(0) do i := i + 1;
  w[0] := chr(i-1);
  for i := 1 to length(w) do w[i] := upcase(w[i]);
  currentdir := '\' + w;
end;

procedure xxdir(x:pathtype; k:integer);
  { executes crdir, mkdir, and rmdir requests.  }
  { requires xxpatherr and current drive, above.}
var w   : pathtype;
    reg :regtype;      {note earlier change in rtype name}
begin
  w := x + chr(0);
  if w[2] <> ':' then   {add drive designator}
    w := currentdrive + w;
  reg.ax := k;
  reg.ds := seg(w[1]);
  reg.dx := ofs(w[1]);
  intr($21,reg);
  if (reg.flags and 1) > 0 then xxpatherr(x);
end;

procedure chdir(x:pathtype);
  {  equivalent to chdir command in dos.              }
  { requires xxdir, xxpatherr, and currentdrive, above}
  { caution!  do not leave a directory                }
  { if you have files in it open                      }
begin
  xxdir(x,$3B00);
end;


procedure rmdir(x:pathtype);
  { equivalen to rmdir command in DOS.                }
  { requires xxdir, xxpatherr, and currentdrive, above}
begin
  xxdir(x,$3a00);
end;

procedure mkdir(x:pathtype);
  {  equivalen to mkdir command in DOS                }
  { requires xxdir, xxpatherr, and currentdrive, above}
begin
  xxdir(x,$3900);
end;

procedure rename(x,y:pathtype);
  { renames a file; unlike thd DOS rename command     }
  { both parameters of this command are full paths.   }
  { the paths need not be the same, allowing a file   }
  { to be moved from one directory to another.        }
  { first parameter can specify a drive; any drive    }
  { letter on the second parameter is ignored.        }
var wx,wy : pathtype;
    reg   : regtype;      {note earlier change in rtype name}
begin
  wx := x + chr(0);
  wy := y + chr(0);
  if wx[2] <> ':' then wx := currentdrive + wx;
  reg.ax := $5600;
  reg.ds := seg(wx[1]);
  reg.dx := ofs(wx[1]);
  reg.es := seg(wy[1]);
  reg.di := ofs(wy[1]);
  intr($21,reg);
  if (reg.flags and 1) <> 0 then
    begin
      writeln('Error -- invalid rename request');
      writeln('      -- from: ''',x,'''');
      writeln('      -- to:   ''',y,'''');
      halt;
    end;
end;

(*************************************************************************)

{ Turbo Pascal removeable window system }
{ copyright 1984 Michael A. Covington }

{ requirements: IBM PC or close compatable      }
{ screen must be in text move, on page 1        }
{ either mon or color card                      }

{ CALL INITWIN BEFOR CALLING MKWIN OR RMWIN!    }

const maxwin = 5;  {maximum number of windows open at onece }

type imagetype = array[1..4096] of char;
     windimtype = record
                    x1,y1,x2,y2 : integer;
                  end;
var win : record    {global variable package}
            dim   : windimtype;      {current windor dimensions}
            depth : integer;
            stack : array[1..maxwin] of record
                               image : imagetype;  {saved screen image}
                               dim   : windimtype; {saved window dimensions}
                               x,y   : integer     {saved cursor position}
                             end;
          end;
    crtmode       : byte      absolute $0040:$0049;
    crtwidth      : byte      absolute $0040:$004A;
    monobuffer    : imagetype absolute $B000:$0000;
    colorbuffer   : imagetype absolute $b800:$0000;

procedure initwin;
  { records initial window dimension }
begin
  with win.dim do
    begin x1:= 1; y1:= 1; x2:=crtwidth; y2:= 25; end;
  win.depth := 0;
end;

procedure boxwin(x1,y1,x2,y2:integer);
  { draws a box, fills it with blanks, and makes it the current }
  { window.  Dimensions give are for the bos; actual windos is  }
  { one unit smaller in each direction.                         }
  { This routine can be used separately from the rest of the    }
  { removable window package.                                   }
var x,y : integer;
begin
  window(1,1,80,25);
  { TOP }
  gotoxy(x1,y1);
  write(chr(213));
  for x := x1 +1 to x2-1 do write(chr(205));
  write(chr(184));
  { SIDES }
  for y := y1+1  to y2-1 do
    begin
      gotoxy(x1,y);
      write(chr(179),' ':x2-x1-1,chr(179));
    end;
  { BOTTOM }
  gotoxy(x1,y2);
  write(chr(212));
  for x := x1+1 to x2-1 do write(chr(205));
  write(chr(190));
  { make it the current window }
  window(x1+1,y1+1,x2-1,y2-1);
  gotoxy(1,1);
end;

procedure mkwin(x1,y1,x2,y2:integer);
  { create a remiveable window }
begin
  {increment stack pointer }
  with win do depth := depth + 1;
  if win.depth > maxwin then
    begin
      writeln('','Window nested too deep ');
      halt;
    end;
  { save contents of screen }
  if crtmode = 7 then
    win.stack[win.depth].image := monobuffer
  else
    win.stack[win.depth].image := colorbuffer;
  win.stack[win.depth].dim := win.dim;
  win.stack[win.depth].x   := wherex;
  win.stack[win.depth].y   := wherey;
  { create the window }
  boxwin(x1,y1,x2,y2);
  win.dim.x1 := x1 + 1;
  win.dim.y1 := y1 + 1;  { allow for margins }
  win.dim.x2 := x2 - 1;
  win.dim.y2 := y2 - 1;
end;

procedure rmwin;
  { remove the most recently created removable window }
  { restore screen contents, window dimensions, and   }
  { position of cursor.                               }
begin
  if crtmode = 7 then
    monobuffer  := win.stack[win.depth].image
  else
    colorbuffer := win.stack[win.depth].image;
  with win do
    begin
      dim := stack[depth].dim;
      window(dim.x1,dim.y1,dim.x2,dim.y2);
      gotoxy(stack[depth].x,stack[depth].y);
      depth := depth - 1;
    end;
end;